home *** CD-ROM | disk | FTP | other *** search
/ PC World 2006 February / PCWorld_2006-02_cd.bin / software / vyzkuste / audacity / audacity-win-1.2.4b.exe / {app} / Nyquist / seq.lsp < prev    next >
Lisp/Scheme  |  2003-07-01  |  9KB  |  197 lines
  1. ;; seq.lsp -- sequence control constructs for Nyquist
  2.  
  3. ;; get-srates -- this either returns the sample rate of a sound or a
  4. ;;   vector of sample rates of a vector of sounds
  5. ;;
  6. (defun get-srates (sounds)
  7.   (cond ((arrayp sounds)
  8.          (let ((result (make-array (length sounds))))
  9.            (dotimes (i (length sounds))
  10.                     (setf (aref result i) (snd-srate (aref sounds i))))
  11.            result))
  12.         (t
  13.          (snd-srate sounds))))
  14.  
  15. ; These are complex macros that implement sequences of various types.
  16. ; The complexity is due to the fact that a behavior within a sequence
  17. ; can reference the environment, e.g. (let ((p 60)) (seq (osc p) (osc p)))
  18. ; is an example where p must be in the environment of each member of
  19. ; the sequence.  Since the execution of the sequence elements are delayed,
  20. ; the environment must be captured and then used later.  In XLISP, the
  21. ; EVAL function does not execute in the current environment, so a special
  22. ; EVAL, EVALHOOK must be used to evaluate with an environment.  Another
  23. ; feature of XLISP (see evalenv.lsp) is used to capture the environment
  24. ; when the seq is first evaluated, so that the environment can be used
  25. ; later.  Finally, it is also necessary to save the current transformation
  26. ; environment until later.
  27.  
  28. (defmacro seq (&rest list)
  29.   (cond ((null list)
  30.          (snd-zero (warp-time *WARP*) *sound-srate*))
  31.         ((null (cdr list))
  32.          (car list))
  33.         ((null (cddr list))
  34.          ; (format t "SEQ with 2 behaviors: ~A~%" list)
  35.          `(let* ((first%sound ,(car list))
  36.                 (s%rate (get-srates first%sound)))
  37.             (cond ((arrayp first%sound)
  38.                    (snd-multiseq (prog1 first%sound (setf first%sound nil))
  39.                      #'(lambda (t0)
  40.                         (format t "MULTISEQ's 2nd behavior: ~A~%" ',(cadr list))
  41.                         (with%environment ',(nyq:the-environment)
  42. ;                (display "MULTISEQ 1" t0)
  43.                             (at-abs t0
  44.                                 (force-srates s%rate ,(cadr list)))))))
  45.                   (t
  46.                    ; allow gc of first%sound:
  47.                    (snd-seq (prog1 first%sound (setf first%sound nil))
  48.                      #'(lambda (t0) 
  49. ;                        (format t "SEQ's 2nd behavior: ~A~%" ',(cadr list))
  50.                         (with%environment ',(nyq:the-environment)
  51.                             (at-abs t0
  52.                                 (force-srate s%rate ,(cadr list))))))))))
  53.  
  54.         (t
  55.          `(let* ((nyq%environment (nyq:the-environment))
  56.                  (first%sound ,(car list))
  57.                  (s%rate (get-srates first%sound))
  58.                  (seq%environment (getenv)))
  59.             (cond ((arrayp first%sound)
  60. ;           (print "calling snd-multiseq")
  61.                    (snd-multiseq (prog1 first%sound (setf first%sound nil))
  62.                      #'(lambda (t0)
  63.                         (multiseq-iterate ,(cdr list)))))
  64.                   (t 
  65. ;           (print "calling snd-seq")
  66.                    ; allow gc of first%sound:
  67.                    (snd-seq (prog1 first%sound (setf first%sound nil))
  68.                      #'(lambda (t0)
  69.                         (seq-iterate ,(cdr list))))))))))
  70.  
  71. (defun envdepth (e) (length (car e)))
  72.  
  73. (defmacro myosd (pitch)
  74.   `(let () (format t "myosc env depth is ~A~%" 
  75.                    (envdepth (getenv))) (osc ,pitch)))
  76.  
  77. (defmacro seq-iterate (behavior-list)
  78.   (cond ((null (cdr behavior-list))
  79.          `(eval-seq-behavior ,(car behavior-list)))
  80.         (t
  81.          `(snd-seq (eval-seq-behavior ,(car behavior-list))
  82.                    (evalhook '#'(lambda (t0) 
  83.                                   ; (format t "lambda depth ~A~%" (envdepth (getenv)))
  84.                                   (seq-iterate ,(cdr behavior-list)))
  85.                              nil nil seq%environment)))))
  86.  
  87. (defmacro multiseq-iterate (behavior-list)
  88.   (cond ((null (cdr behavior-list))
  89.          `(eval-multiseq-behavior ,(car behavior-list)))
  90.         (t
  91.          `(snd-multiseq (eval-multiseq-behavior ,(car behavior-list))
  92.                    (evalhook '#'(lambda (t0) 
  93.                                   ; (format t "lambda depth ~A~%" (envdepth (getenv)))
  94.                                   (multiseq-iterate ,(cdr behavior-list)))
  95.                              nil nil seq%environment)))))
  96.  
  97. (defmacro eval-seq-behavior (beh)
  98.   `(with%environment nyq%environment 
  99.                      (at-abs t0
  100.                              (force-srate s%rate ,beh))))
  101.  
  102. (defmacro eval-multiseq-behavior (beh)
  103.   `(with%environment nyq%environment 
  104. ;                (display "MULTISEQ 2" t0)
  105.                      (at-abs t0
  106.                              (force-srates s%rate ,beh))))
  107.  
  108. (defmacro with%environment (env &rest expr)
  109.   `(progv ',*environment-variables* ,env ,@expr))
  110.  
  111.  
  112.  
  113. (defmacro seqrep (pair sound)
  114.   `(let ((,(car pair) 0)
  115.          (loop%count ,(cadr pair))
  116.          (nyq%environment (nyq:the-environment))
  117.          seqrep%closure first%sound s%rate)
  118.      ; note: s%rate will tell whether we want a single or multichannel
  119.      ; sound, and what the sample rates should be.
  120.      (cond ((not (integerp loop%count))
  121.             (error "bad argument type" loop%count))
  122.            (t
  123.             (setf seqrep%closure #'(lambda (t0)
  124. ;          (display "SEQREP" loop%count ,(car pair))
  125.               (cond ((< ,(car pair) loop%count)
  126.                      (setf first%sound 
  127.                            (with%environment nyq%environment
  128.                                              (at-abs t0 ,sound)))
  129.                      ; (display "seqrep" s%rate nyq%environment ,(car pair)
  130.                      ;          loop%count)
  131.                      (if s%rate
  132.                        (setf first%sound (force-srates s%rate first%sound))
  133.                        (setf s%rate (get-srates first%sound)))
  134.                      (setf ,(car pair) (1+ ,(car pair)))
  135.                      ; note the following test is AFTER the counter increment
  136.                      (cond ((= ,(car pair) loop%count)
  137. ;                            (display "seqrep: computed the last sound at"
  138. ;                               ,(car pair) loop%count
  139. ;                               (local-to-global 0))
  140.                             first%sound) ;last sound
  141.                            ((arrayp s%rate)
  142. ;                            (display "seqrep: calling snd-multiseq at"
  143. ;                             ,(car pair) loop%count (local-to-global 0) 
  144. ;                             (snd-t0 (aref first%sound 0)))
  145.                             (snd-multiseq (prog1 first%sound
  146.                                                  (setf first%sound nil))
  147.                                           seqrep%closure))
  148.                            (t
  149. ;                            (display "seqrep: calling snd-seq at"
  150. ;                             ,(car pair) loop%count (local-to-global 0) 
  151. ;                             (snd-t0 first%sound))
  152.                             (snd-seq (prog1 first%sound
  153.                                             (setf first%sound nil))
  154.                                      seqrep%closure))))
  155.                     (t (snd-zero (warp-time *WARP*) *sound-srate*)))))
  156.             (funcall seqrep%closure (local-to-global 0))))))
  157.  
  158.  
  159. ;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...))
  160. ;; a timed-seq takes a list of events as shown above
  161. ;; it sums the behaviors, similar to 
  162. ;;     (sim (at time1 (stretch stretch1 expr1)) ...)
  163. ;; but the implementation avoids starting all expressions at once
  164. ;; 
  165. ;; Notes: (1) the times must be in increasing order
  166. ;;   (2) EVAL is used on each event, so events cannot refer to parameters
  167. ;;        or local variables
  168. ;;
  169. (defun timed-seq (score)
  170.   ; check to insure that times are strictly increasing and >= 0 and stretches are >= 0
  171.   (let ((start-time 0) error-msg)
  172.     (dolist (event score)
  173.       (cond ((< (car event) start-time)
  174.              (error (format nil "Out-of-order time in TIMED-SEQ: ~A" event)))
  175.             ((< (cadr event) 0)
  176.              (error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event)))
  177.             (t
  178.              (setf start-time (car event)))))
  179.     (cond ((null score) (s-rest 0))
  180.           (t
  181.            (at (caar score)
  182.                (seqrep (i (length score))
  183.                  (cond ((cdr score)
  184.                         (let (event)
  185.                           (prog1
  186.                             (set-logical-stop
  187.                               (stretch (cadar score)
  188.                               (setf event (eval (caddar score))))
  189.                             (- (caadr score) (caar score)))
  190. ;                           (display "timed-seq" (caddar score) (local-to-global 0))
  191.                             (setf score (cdr score)))))
  192.                          (t
  193.                           (stretch (cadar score) (eval (caddar score)))))))))))
  194.  
  195.  
  196.  
  197.